home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / tforth21.lha / tile-forth-2.1 / lib / objects.f83 < prev    next >
Text File  |  1991-09-14  |  4KB  |  179 lines
  1. \
  2. \  OBJECT ORIENTED PROGRAMMING LIBRARY: CLASS-INSTANCE MODEL
  3. \
  4. \  Copyright (C) 1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 15 August 1990
  15. \
  16. \  Last updated on: 3 September 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, prototypes
  20. \
  21. \  Description:
  22. \       This library supports the classical object oriented programming
  23. \       model of classes and instances. The class domain is here realized
  24. \       with the prototype library. A class may have a set of methods for
  25. \       messages, a set of instance variables, and may inherit additional
  26. \       features from a super class.
  27. \
  28. \       A syntax similar to Smalltalk is used. The object, instance, to
  29. \       receive a message is always the first parameter. A message does
  30. \       not require a prefix operator. All fields, instance variables,
  31. \       are accessed with memory access words. The variable names will
  32. \       retrieve the corresponding position in the instance. The first cell
  33. \       of an instance is alway a pointer to the class (prototype).
  34. \
  35. \  Copying:
  36. \       This program is free software; you can redistribute it and\or modify
  37. \       it under the terms of the GNU General Public License as published by
  38. \       the Free Software Foundation; either version 1, or (at your option)
  39. \       any later version.
  40. \
  41. \       This program is distributed in the hope that it will be useful,
  42. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  43. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  44. \       GNU General Public License for more details.
  45. \
  46. \       You should have received a copy of the GNU General Public License
  47. \       along with this program; see the file COPYING.  If not, write to
  48. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  49.  
  50. .( Loading Objects definitions...) cr
  51.  
  52. #include prototypes.f83
  53.  
  54. vocabulary objects ( -- )
  55.  
  56. prototypes objects definitions
  57.  
  58. \ Class slots for instance size and instance variable
  59.  
  60. slot instance-size: ( class -- num) private
  61. slot instance-variables: ( class -- entry) private
  62. slot instance-disposed: ( class -- object) private
  63.  
  64. variable the-class ( -- addr) private
  65.  
  66. : this-class ( -- class)
  67.   the-class @ [compile] literal
  68. ; immediate
  69.  
  70. : subclass ( superclass -- offset0)
  71.   dup prototype this-prototype the-class ! ?dup
  72.   if instance-size: else cell then
  73. ;
  74.  
  75. : bytes ( offset1 size -- offset2)  
  76.   over field +
  77. ;
  78.  
  79. : subclass.field ( size -- )  
  80.   create ,
  81. does> ( subclass.field -- )
  82.   @ bytes
  83. ; private
  84.  
  85. 1 subclass.field byte ( -- )
  86. 2 subclass.field word ( -- )
  87. 4 subclass.field long ( -- )
  88. 4 subclass.field ptr  ( -- )
  89. 4 subclass.field enum ( -- )
  90.  
  91. : align ( offset1 -- offset2)  
  92.   dup 1 and +
  93. ;
  94.  
  95. : subclass.end ( offset3 -- )
  96.   the-class @ tuck -> instance-size: 
  97.   last over -> instance-variables: 
  98.   nil over -> instance-disposed:
  99.   prototype>entry restore
  100.   nil the-class !
  101. ;
  102.  
  103. : superclass ( class1 -- class2)
  104.   parent
  105. ;
  106.  
  107. : canUnderstand ( message class -- bool)
  108.   delegate if drop true else 2drop false then
  109. ;
  110.  
  111. : basicInstanceSize ( class -- num)
  112.   instance-size:
  113. ;
  114.  
  115.  
  116. \ Instance class relation access and class name display functions
  117.  
  118. : class ( object -- addr)
  119.   @
  120. ;
  121.  
  122. : .class ( object -- )
  123.   class .prototype
  124. ;
  125.  
  126. \ Instance creation and definition functions
  127.  
  128. forward initiate ( object -- )
  129.  
  130. : allot-instance ( class -- object)
  131.   here over , swap instance-size: cell - allot dup >r initiate r>
  132. ; private
  133.  
  134. : new-instance ( class -- object)
  135.   dup instance-disposed: ?dup
  136.   if 2dup @ swap -> instance-disposed: tuck ! else allot-instance then
  137. ;
  138.  
  139. : dispose-instance ( object -- )
  140.   dup class 2dup instance-disposed: swap ! -> instance-disposed:
  141. ;
  142.  
  143. : instance ( class -- )
  144.   create allot-instance drop
  145. ;
  146.  
  147. \ Message and method definition
  148.  
  149. forward doesNotUnderstand ( message object -- )
  150.  
  151. : send ( object message class -- object)
  152.   delegate if >r else drop swap doesNotUnderstand then
  153. ;
  154.  
  155. : message ( -- )
  156.   message
  157. does> ( object message -- object)
  158.   over class send
  159. ;
  160.  
  161. : .message ( message -- )
  162.   .message
  163. ;
  164.  
  165. : method ( -- )
  166.   the-class @ method 
  167. ;
  168.  
  169. : super ( -- )
  170.   the-class @ superclass ?dup
  171.   if ' >body [compile] literal [compile] literal compile send
  172.   else
  173.     the-class @ .class space ." has no superclass" cr abort
  174.   then
  175. ; immediate compilation 
  176.  
  177. forth only
  178.  
  179.